Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue34/alfresco/Ternary.pas

Pascal/Delphi Source File | 1998-07-03 | 9.0 KB | 315 lines

{*********************************************************}
{* Ternary                                               *}
{* Copyright (c) Julian M Bucknall 1998                  *}
{* All rights reserved.                                  *}
{*********************************************************}
{* A ternary search tree class                           *}
{*********************************************************}

{Note: this unit is released as freeware. In other words, you are free
       to use this unit in your own applications, however I retain all
       copyright to the code. JMB}

{$IFDEF VER80}
!! Error
This unit uses long strings only. In other words, you must be using
Delphi 2 or later.
{$ENDIF}

unit Ternary;

interface

uses
  SysUtils;

type
  PTSTNode = ^TTSTNode;
  TTSTNode = record
    Left, Equal, Right : PTSTNode;
    EqualChar : char;
    NullInUse : boolean;
  end;

type
  TTSTActionProc = procedure(const S : string; Data : pointer);

type
  TTernaryTree = class
    {-a ternary search tree}
    protected {private}
      FCount      : integer;
      FIgnoreCase : boolean;
      FRoot       : PTSTNode;
    protected
      procedure SetIgnoreCase(Value : boolean);
    public
      constructor Create;
      destructor Destroy; override;

      procedure Insert(const S : string; aData : pointer);
        {-insert a string with associated data}
      procedure Delete(const S : string);
        {-delete a string; associated data is not freed}
      procedure Iterate(Action : TTSTActionProc);
        {-iterate through all the strings, calling Action for each}
      procedure PartialSearch(const S : string; Action : TTSTActionProc);
        {-search for a pattern string, calling Action for all matches}
      function Search(const S : string; var aData : pointer) : boolean;
        {-search for a string}

      property Count : integer read FCount;
        {-count of strings}
      property IgnoreCase : boolean read FIgnoreCase write SetIgnoreCase;
        {-make tree case-sensitive (false) or case-insensitive (true)}
  end;

implementation

{===Recursives=======================================================}
procedure DeleteAllNodesPrim(Node : PTSTNode);
begin
  if (Node = nil) then
    Exit;
  DeleteAllNodesPrim(Node^.Left);
  if (Node^.EqualChar <> #0) then
    DeleteAllNodesPrim(Node^.Equal);
  DeleteAllNodesPrim(Node^.Right);
  Dispose(Node);
end;
{--------}
function DeletePrim(const S : string; Inx : integer; Node : PTSTNode) : boolean;
begin
  Result := false;
  if (Node = nil) then
    Exit;
  with Node^ do begin
    if (S[Inx] < EqualChar) then begin
      if DeletePrim(S, Inx, Left) then
        Left := nil
    end
    else if (S[Inx] > EqualChar) then begin
      if DeletePrim(S, Inx, Right) then
        Right := nil
    end
    else {they're equal} begin
      if (EqualChar = #0) then begin
        Equal := nil;
        NullInUse := false;
      end
      else begin
        inc(Inx);
        if DeletePrim(S, Inx, Equal) then
          Equal := nil;
      end;
    end;
    if (Left = nil) and (Right = nil) and (Equal = nil) then begin
      Dispose(Node);
      Result := true;
    end;
  end;
end;
{--------}
function InsertPrim(const S : string; aInx : integer;
                    aData : pointer; aNode : PTSTNode) : PTSTNode;
var
  NewNode : boolean;
begin
  {if the passed node is nil, create a new one; note whether created}
  if (aNode <> nil) then
    NewNode := false
  else {aNode is nil} begin
    NewNode := true;
    aNode := AllocMem(sizeof(TTSTNode));
    aNode^.EqualChar := S[aInx];
  end;
  {if the current char is less than the equal char, go left}
  if (S[aInx] < aNode^.EqualChar) then
    aNode^.Left := InsertPrim(S, aInx, aData, aNode^.Left)
  {if the current char is greater than the equal char, go right}
  else if (S[aInx] > aNode^.EqualChar) then
    aNode^.Right := InsertPrim(S, aInx, aData, aNode^.Right)
  {otherwise the characters are equal}
  else begin
    {if the current char is non-null, increment current character,
     follow equal link}
    if (S[aInx] <> #0) then
      aNode^.Equal := InsertPrim(S, succ(aInx), aData, aNode^.Equal)
    {otherwise the current character is null: save the data pointer}
    else {it's a null} begin
      if (not NewNode) and aNode^.NullInUse then
        raise Exception.Create('Insert: duplicate string');
      aNode^.Equal := PTSTNode(aData);
      aNode^.NullInUse := true;
    end;
  end;
  {return the current node}
  Result := aNode;
end;
{--------}
procedure IteratePrim(var S : string; Action : TTSTActionProc; Node : PTSTNode);
begin
  {terminate the recursion, when required}
  if (Node = nil) then
    Exit;
  {visit the left subtree}
  IteratePrim(S, Action, Node^.Left);
  {deal with the node character}
  if (Node^.EqualChar = #0) and Node^.NullInUse then begin
    Action(S, pointer(Node^.Equal));
  end
  else begin
    {visit the equal subtree}
    S := S + Node^.EqualChar;
    IteratePrim(S, Action, Node^.Equal);
    System.Delete(S, length(S), 1);
  end;
  {visit the right subtree}
  IteratePrim(S, Action, Node^.Right);
end;
{--------}
procedure PartialSearchPrim(const S      : string;
                                  Inx    : integer;
                                  Action : TTSTActionProc;
                              var BuildS : string;
                                  Node   : PTSTNode);
begin
  {terminate the recursion, when required}
  if (Node = nil) then
    Exit;
  {visit the left subtree if either the current char is a '.' or it's
   less than the equal char}
  if (S[Inx] = '.') or (S[Inx] < Node^.EqualChar) then
    PartialSearchPrim(S, Inx, Action, BuildS, Node^.Left);
  {deal with the node character}
  if (Node^.EqualChar = #0) and Node^.NullInUse and (S[Inx] = #0) then begin
    Action(BuildS, pointer(Node^.Equal));
  end
  else begin
    {visit the equal subtree if required}
    if (S[Inx] = '.') or (S[Inx] = Node^.EqualChar) then
      if (S[Inx] <> #0) and (Node^.EqualChar <> #0) then begin
        BuildS := BuildS + Node^.EqualChar;
        PartialSearchPrim(S, Inx+1, Action, BuildS, Node^.Equal);
        System.Delete(BuildS, length(BuildS), 1);
      end;
  end;
  {visit the right subtree if either the current char is a '.' or it's
   greater than the equal char}
  if (S[Inx] = '.') or (S[Inx] > Node^.EqualChar) then
    PartialSearchPrim(S, Inx, Action, BuildS, Node^.Right);
end;
{--------}
function SearchPrim(const S : string; var aData : pointer;
                                          aNode : PTSTNode) : boolean;
var
  Inx     : integer;
  CurChar : char;
begin
  Inx := 1;
  CurChar := S[1];
  while (aNode <> nil) do begin
    with aNode^ do begin
      if (CurChar < EqualChar) then
        aNode := Left
      else if (CurChar > EqualChar) then
        aNode := Right
      else {they're equal} begin
        if (CurChar = #0) then begin
          Result := NullInUse;
          aData := pointer(Equal);
          Exit;
        end;
        aNode := Equal;
        inc(Inx);
        CurChar := S[Inx];
      end;
    end;
  end;
  Result := false;
end;
{====================================================================}


{===TTernaryTree=====================================================}
constructor TTernaryTree.Create;
begin
end;
{--------}
destructor TTernaryTree.Destroy;
begin
  DeleteAllNodesPrim(FRoot);
end;
{--------}
procedure TTernaryTree.Insert(const S : string; aData : pointer);
var
  WorkS  : string;
begin
  {prepare}
  if IgnoreCase then
    WorkS := AnsiLowerCase(S)
  else
    WorkS := S;
  {insert}
  FRoot := InsertPrim(WorkS, 1, aData, FRoot);
  inc(FCount);
end;
{--------}
procedure TTernaryTree.Delete(const S : string);
var
  Obj : pointer;
  WorkS  : string;
begin
  if IgnoreCase then
    WorkS := AnsiLowerCase(S)
  else
    WorkS := S;
  if SearchPrim(WorkS, Obj, FRoot) then begin
    if DeletePrim(WorkS, 1, FRoot) then
      FRoot := nil;
    dec(FCount);
  end;
end;
{--------}
procedure TTernaryTree.Iterate(Action : TTSTActionProc);
var
  S : string;
begin
  S := '';
  IteratePrim(S, Action, FRoot);
end;
{--------}
procedure TTernaryTree.PartialSearch(const S : string; Action : TTSTActionProc);
var
  BuildS : string;
  WorkS  : string;
begin
  if IgnoreCase then
    WorkS := AnsiLowerCase(S)
  else
    WorkS := S;
  BuildS := '';
  PartialSearchPrim(WorkS, 1, Action, BuildS, FRoot);
end;
{--------}
function TTernaryTree.Search(const S : string; var aData : pointer) : boolean;
var
  WorkS   : string;
begin
  if IgnoreCase then
    WorkS := AnsiLowerCase(S)
  else
    WorkS := S;
  Result := SearchPrim(WorkS, aData, FRoot)
end;
{--------}
procedure TTernaryTree.SetIgnoreCase(Value : boolean);
begin
  if (FCount > 0) then
    raise Exception.Create('TTernaryTree.IgnoreCase can only be changed when empty');
  FIgnoreCase := Value;
end;
{====================================================================}

end.